home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / CMPAR.FOR < prev    next >
Text File  |  1988-02-08  |  3KB  |  128 lines
  1.       SUBROUTINE CMPAR ( S1, S2, IERR )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **          CMPAR            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          COMPARE UNITS
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CA  94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          COMPARE THE CALCULATED UNITS WITH THE REQUESTED UNITS, IF
  23. C*          THEY ARE THE SAME, SUCCESS, OTHERWISE THE REQUESTED NON-STD
  24. C*          UNITS WERE NOT COMPATIBLE WITH THE STANDARD UNITS.
  25. C*
  26. C*     INPUT ARGUMENTS :
  27. C*          S1 - ONE UNIT STRING
  28. C*          S2 - THE OTHER
  29. C*
  30. C*     OUTPUT ARGUMENTS :
  31. C*          NONE
  32. C*
  33. C*     INTERNAL WORK AREAS :
  34. C*          NONE
  35. C*
  36. C*     COMMON BLOCKS :
  37. C*          NONE
  38. C*
  39. C*     FILE REFERENCES :
  40. C*          NONE
  41. C*
  42. C*     SUBPROGRAM REFERENCES :
  43. C*          NONE
  44. C*
  45. C*     ERROR PROCESSING :
  46. C*          NONE
  47. C*
  48. C*     TRANSPORTABILITY LIMITATIONS :
  49. C*          NONE
  50. C*
  51. C*     ASSUMPTIONS AND RESTRICTIONS :
  52. C*          NONE
  53. C*
  54. C*     LANGUAGE AND COMPILER :
  55. C*          ANSI FORTRAN 77
  56. C*
  57. C*     VERSION AND DATE :
  58. C*          VERSION I.0     24-SEP-85
  59. C*
  60. C*     CHANGE HISTORY :
  61. C*          24-SEP-85    INITIAL VERSION
  62. C*
  63. C***********************************************************************
  64. C*
  65.       CHARACTER *(*) S1, S2
  66.       CHARACTER *6 TOP(50), BOT(50), WORK
  67.       LOGICAL ERROR
  68. C
  69.       ERROR = .FALSE.
  70.       IERR  = 0
  71.       CALL CAPS ( S1 )
  72.       L     = LENGTH ( S1 )
  73. C
  74. C --- PASS 1, REPLACE '-' WITH '*'   AND   '**' WITH '^'
  75. C
  76.       J = 0
  77.       I = 1
  78. 5     IF (S1(I:I) .EQ. '-') THEN
  79.          J = J + 1
  80.          S1(J:J) = '*'
  81. C
  82. C --- ALL OTHER CHARACTERS EXCEPT ' ' GET COPIED
  83. C
  84.       ELSE IF (S1(I:I) .NE. ' ') THEN
  85.          J = J + 1
  86.          S1(J:J) = S1(I:I)
  87.       ENDIF
  88.       I = I + 1
  89.       IF ( I .LE. L )GO TO 5
  90.       S1(J+1:) = ' '
  91. C
  92. C --- PASS 2, PARSE INTO TOKENS
  93. C
  94.       CALL PARSE ( S1, J, TOP, NTOP, ERROR )
  95.       IF ( ERROR ) THEN
  96.          IERR = 1
  97.          RETURN
  98.       ENDIF
  99. C
  100.       K = LENGTH(S2)
  101.       CALL PARSE ( S2, K, BOT, NBOT, ERROR )
  102.       BOT(NBOT+1) = ' '
  103.       IF ( ERROR ) THEN
  104.          IERR = 1
  105.          RETURN
  106.       ENDIF
  107. C
  108. C --- NOW ASCERTAIN THAT TOP AND BOT ARE FUNCTIONALLY IDENTICAL
  109. C --- ( THOUGH NOT INFALLABLE, THIS TEST IS DONE BY SORTING THE
  110. C ---   ARRAYS AND REQUIRING THE RESULT TO BE IDENTICAL.)
  111. C
  112.       IF ( NTOP .NE. NBOT ) THEN
  113.          IERR = 4
  114.       ELSE
  115.          CALL QSORT ( TOP, NTOP, WORK )
  116.          CALL QSORT ( BOT, NBOT, WORK )
  117.          DO 10 I = 1,NTOP
  118.             IF ( TOP(I) .NE. BOT(I) ) GO TO 20
  119. 10          CONTINUE
  120.       ENDIF
  121.       RETURN
  122. 20    IERR = 4
  123.       RETURN
  124.       END
  125. C
  126. C---END CMPAR
  127. C
  128.